(*
This file is part of the Lustre reader

* Copyright (c) 2010, Nicola Camuffo.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*     * Redistributions of source code must retain the above copyright
*       notice, this list of conditions and the following disclaimer.
*     * Redistributions in binary form must reproduce the above copyright
*       notice, this list of conditions and the following disclaimer in the
*       documentation and/or other materials provided with the distribution.
*     * Neither the name of Nicola Camuffo, nor the
*       names of its contributors may be used to endorse or promote products
*       derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ''AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY
* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)


open Lustypes
open Exceptions



(* extracts types from expressions (or left-hand-sides) and verifies in depth if 
	 they are the same. if test is ok returns the type of element, else, if the equality
	 is doubtful, returns T_TOCHECK *)
let deep_match_types tp1 tp2 =

  let rec rmt t1 t2 = match t1,t2 with
		T_NONE,_ -> ()
		| _,T_NONE -> ()

    | T_TOCHECK,_ -> ()
    | _,T_TOCHECK -> ()

    | T_INT,T_INT -> ()
    | T_REAL,T_REAL -> ()
    | T_BOOL,T_BOOL -> ()

    | T_NAMED(id1),T_NAMED(id2) when id1 = id2 -> ()

    | T_TUPLE(l1),T_TUPLE(l2) ->
      if (List.length l1) <> (List.length l2) then (
				let msg = "Type lists have different lengths." in
				raise (Type_mismatch_exception (msg,None))
      );

      List.iter2 rmt l1 l2

    | T_ARRAY(tx,(_,etx)),T_ARRAY(ty,(_,ety)) ->
			rmt tx ty;
			rmt etx ety (* expressions values cannot be evaluated *)
			
    | T_LIST(l1),T_LIST(l2) ->
      if (List.length l1) <> (List.length l2) then (
				let msg = "Type lists have different lengths." in
				raise (Type_mismatch_exception (msg,None))
      );

      List.iter2 rmt l1 l2

    | T_STRUCT(l1),T_STRUCT(l2) -> (
      if (List.length l1) <> (List.length l2) then (
				let msg = "Type lists have different lengths." in
				raise (Type_mismatch_exception (msg,None))
      );

      try
				List.iter (fun (s,t) -> rmt t (List.assoc s l2)) l1 
			with Not_found ->
				let msg = "Struct types have different field names." in
				raise (Type_mismatch_exception (msg,None))
    )

    | T_ENUM(l1),T_ENUM(l2) -> (
      if (List.length l1) <> (List.length l2) then (
				let msg = "Type lists have different lengths." in
				raise (Type_mismatch_exception (msg,None))
      );

      let res = List.for_all (fun s -> List.mem s l2) l1 in
      if (not res) then
				let msg = "Enum types have different constant names." in
				raise (Type_mismatch_exception (msg,None))
    )

    | _,_ ->
      let msg = "Types are different." in
      raise (Type_mismatch_exception (msg,None))
  in

  rmt tp1 tp2;
  if (tp1 = T_TOCHECK || tp2 = T_TOCHECK) then T_TOCHECK else tp1

	
(*	
let deep_match_expressions ex1 ex2 =

  let rec rmt e1 e2 = match e1,e2 with
		E_NONE,_ -> ()
		| _,E_NONE -> ()
*)
		